H|VERSION = 3.00_app.hM( _datasession_app.hPixelsClass1_custom _datasessionvWidth = 24 lsuccess = .T. idatachangedmode = 0 lusetransactions = .T. isavedsessionid = 1 Name = "_datasession" custom _base.vcx_app.hNֽM( _systoolbars+Application Wizard framework class library._app.hPixelsClass1Pixels_traceawaretimer _objectstatePixelsClass1_custom_customcustomClass _base.vcxtimerIiregularinterval = 0 itraceinterval = 10000 Name = "_traceawaretimer"  _objectstate1 _base.vcx_traceawaretimer_timertiregularinterval Standard interval period. itraceinterval Slower interval period you wish to use while debugging. )oobject = .NULL. Name = "_objectstate" custom _base.vcxhHides and shows system toolbars, either automatically (at Init and Destroy of this object) or on demand. _systoolbarsName = "_systoolbars" 1blautomatic Automatically saves/restores properties for oObject. oobject Reference to target object whose state is being saved. *set Sets a property to a new value for oObject. *restore Restores value of a property for oObject. ^aproperties[1,3] Array for saving/restoring properties of oObject. *save Saves current value of a property for oObject. oSaves and restores state for any object either automatically (on Init and Destroy of this object) or on demand._app.h߽M(_error_app.hPixels Error handlerClass_customzTimer with a special (slower) interval for debugging, so that timer events still occur but don't interrupt other tracing._errorcustom _base.vcxKPROCEDURE Init IF NOT DODEFAULT() RETURN .F. ENDIF THIS.iRegularInterval = THIS.Interval ENDPROC PROCEDURE Timer IF WVISIBLE("trace") OR ; WVISIBLE("debugger") OR ; WVISIBLE("call") OR ; WVISIBLE("watch") OR ; WVISIBLE("locals") IF THIS.Interval # THIS.iTraceInterval THIS.iRegularInterval = THIS.Interval THIS.Interval = THIS.iTraceInterval ENDIF ELSE IF THIS.Interval = THIS.iTraceInterval THIS.Interval = THIS.iRegularInterval ENDIF THIS.iRegularInterval = THIS.Interval ENDIF ENDPROC lsuccess Whether data operation (update) was successful. idatachangedmode Detemines what constitutes data change. 0 - anything changed. 1 - ignore view fields not in Updatefields list. 2- ignore views not set to send updates. Subclasses can add more categories and augment DataChanged() method. lusetransactions Whether to wrap updating routine in transaction. Note: tables not in a DBC are unaffected in transaction. isavedsessionid Data session ID. *update Updates data. *revert Reverts data. *datachanged Checks if data has changed, according to the current system as specified in iDataChangedMode. *dataflush Ensures that the activecontrol will have its current contents "recognized" even if you choose to update from a toolbar button while a grid has focus. *getactivecontrolref Returns the real active control such as cases where the current active control is a Grid. *getmessageboxtitle *restoresessionid Restores the data session. *setsessionid Sets the data session. *queryunload Occurs before a Form is unloaded. *datavalid -lautomatic Automatically hides and restores system toolbars for application. *hidesystemtoolbars Manually hides system toolbars for your application. *showsystemtoolbars Manually shows system toolbars for your application. *initializetoolbararray ^asystemtoolbars[1,0] Array of system toolbars.  PROCEDURE set LPARAMETERS tcProperty, tvValue, tlSave IF ISNULL(THIS.oObject) RETURN .F. ENDIF ASSERT TYPE("THIS.oObject."+tcProperty) # "U" LOCAL lcTypeValue lcTypeValue = VARTYPE(tvValue) IF lcTypeValue # TYPE("THIS.oObject."+tcProperty) RETURN .F. ENDIF IF tlSave THIS.Save(tcProperty, lcTypeValue) ENDIF STORE tvValue TO ; ("THIS.oObject."+tcProperty) ENDPROC PROCEDURE restore LPARAMETERS tcWhichProperty IF ISNULL(THIS.oObject) RETURN .F. ENDIF LOCAL lcProperty, liPos, liRow, lvCurrentValue, lcCurrentProperty ASSERT EMPTY(tcWhichProperty) OR VARTYPE(tcWhichProperty) = "C" IF EMPTY(tcWhichProperty) * restore all FOR liRow = 1 TO ALEN(THIS.aProperties,1) IF EMPTY(THIS.aProperties[liRow,1]) LOOP ENDIF lcCurrentProperty = STRTRAN(THIS.aProperties[liRow,1],"#","") lvCurrentValue = EVAL("THIS.oObject."+lcCurrentProperty) * avoid re-setting properties to their current * value because this may cause a "flash" IF THIS.aProperties[liRow,2] = "C" IF lvCurrentValue == THIS.aProperties[liRow,3] LOOP ENDIF ELSE IF lvCurrentValue = THIS.aProperties[liRow,3] LOOP ENDIF ENDIF STORE THIS.aProperties[liRow,3] TO ; ("THIS.oObject."+lcCurrentProperty) ENDFOR ELSE lcProperty = LOWER(tcWhichProperty) liPos = ASCAN(THIS.aProperties,"#"+lcProperty+"#") IF liPos = 0 RETURN .F. ELSE liRow = ASUBSCRIPT(THIS.aProperties, liPos, 1) STORE THIS.aProperties[liRow,3] TO ("THIS.oObject."+lcProperty) ENDIF ENDIF ENDPROC PROCEDURE save LPARAMETERS tcProperty, tcTypeValue ASSERT VARTYPE(tcProperty) = "C" AND NOT EMPTY(tcProperty) ASSERT PCOUNT() < 2 OR VARTYPE(tcTypeValue) = "C" IF ISNULL(THIS.oObject) RETURN .F. ENDIF LOCAL lcProperty, liPos, liRow, lcTypeValue lcProperty = LOWER(tcProperty) liPos = ASCAN(THIS.aProperties,"#"+lcProperty+"#") IF liPos = 0 IF PCOUNT() = 2 lcTypeValue = tcTypeValue ELSE lcTypeValue = TYPE("THIS.oObject."+tcProperty) ENDIF liRow = ALEN(THIS.aProperties,1) IF TYPE("THIS.aProperties[liRow,1]") = "C" liRow = liRow + 1 DIME THIS.aProperties[liRow,3] ENDIF THIS.aProperties[liRow,1] = "#"+lcProperty+"#" THIS.aProperties[liRow,2] = lcTypeValue ELSE liRow = ASUBSCRIPT(THIS.aProperties, liPos, 1) ENDIF THIS.aProperties[liRow,3] = EVAL("THIS.oObject."+lcProperty) ENDPROC PROCEDURE Destroy DODEFAULT() IF THIS.lAutomatic THIS.Restore() ENDIF THIS.oObject = .NULL. ENDPROC PROCEDURE Init LPARAMETERS toObject IF NOT DODEFAULT() RETURN .F. ENDIF IF TYPE("toObject.BaseClass") = "C" THIS.lAutomatic = .T. THIS.oObject = toObject ENDIF ENDPROC  %o>,U(C.%CCCC Ta,CUIINDEXTHISASYSTEMTOOLBARSs(Cl,%CCC h,CUIINDEXTHISASYSTEMTOOLBARS $TStandard"TLayout*TQuery Designer)T View Designer)T Color Palette)T Form Controls-TDatabase Designer+TReport Designer+T Report Controls)T  Print Preview)T  Form DesignerUTHISASYSTEMTOOLBARS- C%& CUTHIS LAUTOMATICSHOWSYSTEMTOOLBARSf%C B- C% _Ta CUTLAUTOTHISINITIALIZETOOLBARARRAY LAUTOMATICHIDESYSTEMTOOLBARShidesystemtoolbars,showsystemtoolbarsinitializetoolbararraytDestroyhInit1qaAA3qaAA5aB!3A2qqArA1 [,"v52)@PROCEDURE hidesystemtoolbars LOCAL iIndex FOR iIndex = 1 TO ALEN(THIS.aSystemToolbars,1) * note: it is possible for them to have been RELEASEd * and not exist at all IF WEXIST(THIS.aSystemToolbars[iIndex,1]) AND ; WVISIBLE(THIS.aSystemToolbars[iIndex,1]) THIS.aSystemToolbars[iIndex,2] = .T. HIDE WINDOW (THIS.aSystemToolbars[iIndex,1]) ENDIF ENDFOR ENDPROC PROCEDURE showsystemtoolbars LOCAL iIndex FOR iIndex = 1 TO ALEN(THIS.aSystemToolbars,1) IF WEXIST(THIS.aSystemToolbars[iIndex,1]) AND ; THIS.aSystemToolbars[iIndex,2] SHOW WINDOW (THIS.aSystemToolbars[iIndex,1]) ENDIF ENDFOR ENDPROC PROCEDURE initializetoolbararray DIME THIS.aSystemToolbars[11,2] THIS.aSystemToolbars[1,1]= TB_STANDARD_LOC THIS.aSystemToolbars[2,1]= TB_LAYOUT_LOC THIS.aSystemToolbars[3,1]= TB_QUERY_LOC THIS.aSystemToolbars[4,1]= TB_VIEWDESIGNER_LOC THIS.aSystemToolbars[5,1]= TB_COLORPALETTE_LOC THIS.aSystemToolbars[6,1]= TB_FORMCONTROLS_LOC THIS.aSystemToolbars[7,1]= TB_DATADESIGNER_LOC THIS.aSystemToolbars[8,1]= TB_REPODESIGNER_LOC THIS.aSystemToolbars[9,1]= TB_REPOCONTROLS_LOC THIS.aSystemToolbars[10,1]= TB_PRINTPREVIEW_LOC THIS.aSystemToolbars[11,1]= TB_FORMDESIGNER_LOC ENDPROC PROCEDURE Destroy DODEFAULT() IF THIS.lAutomatic THIS.ShowSystemToolbars() ENDIF ENDPROC PROCEDURE Init LPARAMETERS tlAuto IF NOT DODEFAULT() RETURN .F. ENDIF THIS.InitializeToolbarArray() IF THIS.lAutomatic OR tlAuto THIS.lAutomatic = .T. THIS.HideSystemToolbars() ENDIF ENDPROC  %AF]U%C(B-!C THIS.oObject.bUTC$%C THIS.oObject.bB- %C!J( THIS.oObject.U TCPROPERTYTVVALUETLSAVETHISOOBJECT LCTYPEVALUESAVE.%C B-C CC %C(C%CC.!TCC# TC THIS.oObject.%CC'%C#.S%CO.,JC( THIS.oObject.'TC@ TC##%B-#TC,JC( THIS.oObject.U TCWHICHPROPERTYTHISOOBJECT LCPROPERTYLIPOSLIROWLVCURRENTVALUELCCURRENTPROPERTY APROPERTIES CCC Ct CC %C[B-TC@ TC##%%Ct T TC THIS.oObject.bTC-%CTHIS.aProperties[liRow,1]bCeT&T##TTC/TC THIS.oObject.U TCPROPERTY TCTYPEVALUETHISOOBJECT LCPROPERTYLIPOSLIROW LCTYPEVALUE APROPERTIES; C%& CTUTHIS LAUTOMATICRESTOREOOBJECTk%C B-&%CtoObject.BaseClassbCdTaTUTOOBJECTTHIS LAUTOMATICOOBJECTset,restoreLsaveDestroyJInit1"qArBqAQA8q"qArAAAAAABBrBB4"qA2ARaAbB3A2qqAbB2 3' bN T& )J 11%U/%C B-TUTHISIREGULARINTERVALINTERVALO%CtraceCdebugger Ccall Cwatch Clocals %TT%TTUTHISINTERVALITRACEINTERVALIREGULARINTERVALInit,Timer1qA12r11Ar1A1B1b~@)1+ ++! %&*'U CLCLGCtoSession.DataSessionIDbNC_SCREEN.ActiveFormbO CLC MULTILOCKSvON?     +%CtoSession.DataSessionIDbN T6T9CTa % T TaTC %"%CShowh  C/TCOK to save your edit?!Cx%  %C Z Ta T CW(C y FC T C BufferingTC SourceTypeC  H   . C g%Ca/cT-C zC  AT C T% .+ % T,CC ZT C %C %TC\-!%C CCS  H_   C*Records have been locked by another user. C C AYou can't update these records until the other lock is cancelled.C: Cx Ca-= %9FC 2 %dFC %CAOther people may have edited the data since you started editing. C C !OK to overwrite others' changes, C 2or cancel your edit for the records in this table?1C: Cxn%Caap %lFC jT- %@FC C*Records have been locked by another user. C C AYou can't update these records until the other lock is cancelled.C: CxfC zC T-=T-C*Records have been locked by another user. C C AYou can't update these records until the other lock is cancelled.C: Cx C+  ]. p %CS  H   : C*Records have been locked by another user. C C AYou can't update these records until the other lock is cancelled.C: Cx C--l %h FC 2 % FC %CAOther people may have edited the data since you started editing. C C !OK to overwrite others' changes, C 2or cancel your edit for the records in this table?1C: Cx %C-a % FC  T- %o FC C*Records have been locked by another user. C C AYou can't update these records until the other lock is cancelled.C: Cx C zC  T-l T-C*Records have been locked by another user. C C AYou can't update these records until the other lock is cancelled.C: Cx2 T- % FC  Z%  !%C  %  % ^ (C Z CaC  F $%CRefreshh  C C!B   UTLUSERCHOICEALREADYCONFIRMEDTLDATACHANGEALREADYCONFIRMED TOSESSIONTLNOSHOWLLCHANGE LICONFIRMED LIINDEXTABLES LOSESSIONLCRECSLATABLES LIBUFFERMODELISELECTLAERRORS LIRECMODIFIEDLLUSETRANSACTIONSLLVIEW ACTIVEFORMTHIS SETSESSIONID DATASESSIONIDLSUCCESS DATACHANGEDSHOWGETMESSAGEBOXTITLELUSETRANSACTIONSREFRESHRESTORESESSIONIDCLCLGCtoSession.DataSessionIDbNC_SCREEN.ActiveFormbO CLC MULTILOCKSvON+%CtoSession.DataSessionIDbN TT9 C %E TTC %"%CShowh  C4TCOK to cancel your changes?!C x T%h(Cyd(%C BufferingC`CaC%%CRefreshh  C C BUTLUSERCHOICEALREADYCONFIRMEDTLDATACHANGEALREADYCONFIRMED TOSESSIONTLNOSHOW LICONFIRMEDLIINDEXLATABLESLLCHANGE LOSESSION ACTIVEFORMTHIS SETSESSIONID DATASESSIONID DATACHANGEDSHOWGETMESSAGEBOXTITLEREFRESHRESTORESESSIONID 0CtoSession.DataSessionIDbNC 1   +%CtoSession.DataSessionIDbNC J(%CNT  TCN%C  /B-(CyvT C TTC Buffering C HY C s C%C +  H WT C % C1C .QE TS T2%C =1C SourceType  O T1T ,CCUpdatableFieldList f,T C , ,(C .K;%C \1,CC /f,  G T! 9%C SourceType C SendUpdates 2TCC C1C .Q622TCC C1C .Q6 CQ H;M !%C SourceType TC TCC +C O6TC T1T ,CCUpdatableFieldList f,T C , ,+ W# T C % C1C .Q{ T@ T2%C =1C SourceType  < T(C .8;%C \1,CC /f,  4 T!TC %C O% # 6%C N H #  29%C SourceType C SendUpdates .TC 2MTC 2Y%r!+%CtoSession.DataSessionIDbN C  BU TOSESSION TICHANGEMODELIACTIONLIINDEXLATABLES LIBUFFERMODE LICHANGEMODELIFIELDLICURRENTRECORD LCFIELDSTATES LCFIELDLISTLCALIASTHIS SETSESSIONID DATASESSIONIDIDATACHANGEDMODE DATAFLUSHLIRECORDRESTORESESSIONID 4%C _SCREEN.ActiveForm.ActiveControlbOCBTC9%CloActiveControl.ValuebU(CloActiveControl.ControlSourcebU CbU /CloActiveControl.ReadOnlybU  C  %.C"TCC.=W TC4%CC BUFFERING CCO h%CCOS IC*Records have been locked by another user. C C AYou can't update these records until the other lock is cancelled.C : CxB-dZ#COTU LOACTIVECONTROLLCALIASTHISGETACTIVECONTROLREF ACTIVEFORM ACTIVECONTROL CONTROLSOURCEREADONLYVALUEGETMESSAGEBOXTITLE-%CtoActiveControl.BaseClassbCJB-%CfGRIDT%.%  TC loColumn. ! T BU TOACTIVECONTROLLOREALACTIVECONTROL LITHISCOLUMNLOCOLUMN BASECLASS ACTIVECOLUMNCOLUMNS COLUMNORDERREADONLYBOUNDCURRENTCONTROLB Data MessageU6!%C DATASESSIONv/G(UTHISISAVEDSESSIONIDc-%CNC DATASESSIONv \TC DATASESSIONv G(U TISESSIONTHISISAVEDSESSIONIDaCLGCtoSession.DataSessionIDbNC_SCREEN.ActiveFormbO CL+%CtoSession.DataSessionIDbN TT9C T C %"%CShowh E C yTCYou have work in progress here.C C 0Do you want to save your changes before closing?3C x T H?  Caa   7Caa2? CBUTLDATACHANGEALREADYCONFIRMED TOSESSIONTLNOSHOWLIRESULTLLCHANGE LOSESSION ACTIVEFORMTHIS SETSESSIONID DATASESSIONID DATACHANGEDSHOWGETMESSAGEBOXTITLEUPDATEREVERTRESTORESESSIONIDX CzT-%CfUPDATE4%C,-./6  o+>o_JC5HIW\^:4 C  CC (C0QCUNERRORCMETHODNLINELAERRORSTHISLSUCCESS9%C B-TC DATASESSIONvUTHISISAVEDSESSIONIDupdate,reverts datachanged. dataflushgetactivecontrolrefgetmessageboxtitle restoresessionid setsessionid ! queryunload!Error$InitR&11rA2"BABQA"BRBBA"AA!B !A!Ah !A" ABAA BE2 !A!Ae !A! AAAA BB"AAAABQAABQAABAC31rA2"ACBAQABBRA21ARB#tBRSF#ABAAA#A%BBR21A"AAAAA1A11AAAA1A3BGBABA3BAA R!ABQ r5AB2D5qrA!AAAAAAB2Q2B3qB2rA2$AB11B3) YERB3qA2**0T0QJ?qJ QiV7QSkT 0 lcRecs = lcRecs+","+ALLTR(STR(liRecModified)) ENDIF liRecModified = GETNEXTMODIFIED(liRecModified) ENDDO *&* We are only worrying about one table at a time; *&* presumably there is additional data-specific code in the *&* form itself that *&* preserves referential integrity *&* if the tables are *not* in a DBC and protected by the transaction. IF NOT EMPTY(lcRecs) lcRecs = SUBSTR(lcRecs,2) ELSE *&* all changed records are newly added ENDIF IF EMPTY(lcRecs) OR llView OR RLOCK(lcRecs,ALIAS()) DO CASE CASE NOT THIS.lSuccess * this may only be a problem with VFP3. * it's possible for the RLOCK() to cause * an error rather than a failed update = MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ; MB_OK+MB_ICONSTOP,; THIS.GetMessageBoxTitle()+": "+ALIAS()) CASE TABLEUPDATE(.T.,.F.) * success IF llView SELECT (laTables[liIndexTables,1]) ENDIF OTHERWISE IF llView SELECT (laTables[liIndexTables,1]) ENDIF * could go through the delimited string here * and ask record by record... IF MESSAGEBOX(DATA_HAS_BEEN_EDITED_LOC, ; MB_OKCANCEL+MB_ICONEXCLAMATION,; THIS.GetMessageBoxTitle()+": "+ALIAS()) = IDOK IF TABLEUPDATE(.T.,.T.) * success IF llView SELECT (laTables[liIndexTables,1]) ENDIF ELSE * real error -- *UNLESS* it's a view, in which * case taking the lock wouldn't help, could * actually prevent SET REPROCESS from working * normally! THIS.lSuccess = .F. IF llView SELECT (laTables[liIndexTables,1]) = MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ; MB_OK+MB_ICONSTOP,; THIS.GetMessageBoxTitle()+": "+ALIAS()) ELSE =AERROR(laErrors) ERROR laErrors[1,1] ENDIF ENDIF ELSE THIS.lSuccess = .F. ENDIF ENDCASE ELSE THIS.lSuccess = .F. = MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ; MB_OK+MB_ICONSTOP,; THIS.GetMessageBoxTitle()+": "+ALIAS()) ENDIF CASE (EOF()) AND liBuffermode = DB_BUFOPTRECORD * do nothing if we're at EOF() and optimistic record locking ... * this is permissible if a relation is 1 to 0..n * and may happen if you have chosen to use * optimistic record buffering on child tables. LOOP CASE liBuffermode = DB_BUFOPTRECORD IF llView OR RLOCK() DO CASE CASE NOT THIS.lSuccess * see comment above; this really shouldn't happen = MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ; MB_OK+MB_ICONSTOP,; THIS.GetMessageBoxTitle()+": "+ALIAS()) CASE TABLEUPDATE(.F.,.F.) * success IF llView SELECT (laTables[liIndexTables,1]) ENDIF OTHERWISE * were other people working on the record? * you could do a more elaborate dialog here, * using OLDVAL() and CURVAL() to show what has occurred IF llView SELECT (laTables[liIndexTables,1]) ENDIF IF MESSAGEBOX(DATA_HAS_BEEN_EDITED_LOC, ; MB_OKCANCEL+MB_ICONEXCLAMATION,; THIS.GetMessageBoxTitle()+": "+ALIAS()) = IDOK IF TABLEUPDATE(.F.,.T.) * success IF llView SELECT (laTables[liIndexTables,1]) ENDIF ELSE * real error -- *UNLESS* it's a view, in which * case taking the lock wouldn't help, could * actually prevent SET REPROCESS from working * normally! THIS.lSuccess = .F. IF llView SELECT (laTables[liIndexTables,1]) = MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ; MB_OK+MB_ICONSTOP,; THIS.GetMessageBoxTitle()+": "+ALIAS()) ELSE = AERROR(laErrors) ERROR laErrors[1,1] ENDIF ENDIF ELSE THIS.lSuccess = .F. ENDIF ENDCASE ELSE THIS.lSuccess = .F. = MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ; MB_OK+MB_ICONSTOP,; THIS.GetMessageBoxTitle()+": "+ALIAS()) ENDIF OTHERWISE * we're either at EOF() and * opt record locking or * in trouble -- the assertion uptop * should be taking care of this! THIS.lSuccess = .F. ENDCASE IF llView *&* JIC! SELECT (laTables[liIndexTables,1]) ELSE UNLOCK && this file ENDIF IF NOT THIS.lSuccess EXIT ENDIF ENDFOR *&* outer transaction covering all tables *&* Tablereverts of what is left un-Updated *&* may still help if there are free tables. *&* Again, this will not cover the *&* problem of a partial update already *&* having been committed if there are *&* free tables, but RI code should have *&* been in place to prevent something *&* "really bad" happening in this case. IF llUseTransactions AND TXNLEVEL() > 0 IF THIS.lSuccess END TRANSACTION ELSE ROLLBACK ENDIF ENDIF IF NOT THIS.lSuccess FOR liIndexTables = 1 TO ALEN(laTables,1) =TABLEREVERT(.T.,laTables[liIndexTables,1]) ENDFOR ENDIF *&* SELECT (liSelect) IF llChange AND PEMSTATUS(loSession,"Refresh",5) loSession.Refresh() ENDIF ENDIF THIS.RestoreSessionID() RETURN (NOT llChange) OR (liConfirmed = IDOK AND THIS.lSuccess) ENDPROC PROCEDURE revert LPARAMETERS tlUserChoiceAlreadyConfirmed, tlDataChangeAlreadyConfirmed, toSession, tlNoShow ASSERT VARTYPE(tlUserChoiceAlreadyConfirmed) = "L" ASSERT VARTYPE(tlDataChangeAlreadyConfirmed) = "L" ASSERT TYPE("toSession.DataSessionID") = "N" OR ; TYPE("_SCREEN.ActiveForm") = "O" ASSERT VARTYPE(tlNoShow) = "L" ASSERT SET("MULTILOCKS") = "ON" LOCAL liConfirmed, liIndex, laTables[1], llChange, loSession IF TYPE("toSession.DataSessionID") = "N" loSession = toSession ELSE loSession = _SCREEN.ActiveForm ENDIF THIS.SetSessionID(loSession.DataSessionID) IF tlUserChoiceAlreadyConfirmed liConfirmed = IDOK ELSE llChange = tlDataChangeAlreadyConfirmed OR THIS.DataChanged() IF llChange IF PEMSTATUS(loSession,"Show",5) AND NOT tlNoShow loSession.Show() ENDIF liConfirmed =MESSAGEBOX(DATA_OK_TO_REVERT_LOC,; MB_ICONQUESTION+MB_OKCANCEL,THIS.GetMessageBoxTitle()) ELSE liConfirmed = IDCANCEL ENDIF ENDIF IF liConfirmed = IDOK FOR liIndex = 1 TO AUSED(laTables) IF CURSORGETPROP("Buffering",laTables[liIndex,1]) # DB_BUFOFF =TABLEREVERT(.T.,laTables[liIndex,1]) ENDIF ENDFOR ENDIF IF PEMSTATUS(loSession,"Refresh",5) AND NOT tlNoShow loSession.Refresh() ENDIF THIS.RestoreSessionID() RETURN (liConfirmed = IDOK) ENDPROC PROCEDURE datachanged LPARAMETERS toSession, tiChangeMode ASSERT TYPE("toSession.DataSessionID") = "N" OR ; EMPTY(toSession) LOCAL liAction, liIndex, laTables[1], liBufferMode, liChangeMode, ; liField, liCurrentRecord, ; lcFieldStates, lcFieldList, lcAlias IF TYPE("toSession.DataSessionID") = "N" THIS.SetSessionID(toSession.DataSessionID) ENDIF STORE 0 TO liAction, liBufferMode, liField, ; liCurrentRecord IF VARTYPE(tiChangeMode) # "N" liChangeMode = THIS.iDataChangedMode ELSE liChangeMode = tiChangeMode ENDIF ASSERT VARTYPE(liChangeMode) = "N" * take care of current control if necessary: IF NOT THIS.DataFlush() && will only happen in a pessimistic && buffering mode where we shouldn't && actually be editing this table! RETURN .F. ENDIF FOR liIndex = 1 TO AUSED(laTables) lcAlias = laTables[liIndex,1] liAction = 0 liBuffermode = CURSORGETPROP("Buffering", lcAlias) ASSERT INLIST(liBufferMode,DB_BUFOFF,DB_BUFLOCKRECORD,DB_BUFLOCKTABLE,DB_BUFOPTRECORD,DB_BUFOPTTABLE) DO CASE CASE ISREADONLY(lcAlias) * don't bother... CASE INLIST(liBufferMode, DB_BUFLOCKRECORD, DB_BUFOPTRECORD) * row buffering IF NOT EOF(lcAlias) * problem with GETFLDSTATE returning .NULL. at EOF()!! DO CASE CASE liChangeMode = 1 * This is one of two "nondefault cases" currently known; * It indicates "ignore columns in views that * are not in the UpdateFields list for that view * when assessing data changes" lcFieldStates = GETFLDSTATE(-1,lcAlias) IF lcFieldStates = REPL("1",FCOUNT(lcAlias)+1) liAction = 0 ELSE liAction = 1 * now exempt the alias in specific circumstances IF LEFT(lcFieldStates,1) = "1" AND ; CURSORGETPROP("SourceType", lcAlias) # 3 * we're in a local or remote view, not a table, * and no deletion was carried out liAction = 0 lcFieldList =","+UPPER(CURSORGETPROP("UpdatableFieldList",lcAlias))+"," lcFieldList = STRTRAN(lcFieldList,", ", ",") FOR liField = 1 TO FCOUNT(lcAlias) IF SUBSTR(lcFieldStates,liField+1,1) # "1" AND ; (","+UPPER(FIELD(liField,lcAlias))+"," $ ; lcFieldList) liAction = 1 EXIT ENDIF ENDFOR ENDIF ENDIF CASE liChangeMode = 2 * the second currently-possible "nondefault" case; * it indicates "ignore views that are not set * to send updates back to their tables for the * purposes of assessing data as changed" IF CURSORGETPROP("SourceType", lcAlias) = 3 OR ; CURSORGETPROP("SendUpdates", lcAlias) liAction = IIF(GETFLDSTATE(-1,lcAlias) = ; REPL("1",FCOUNT(lcAlias)+1), ; 0,1) ENDIF OTHERWISE * original code applies liAction = IIF(GETFLDSTATE(-1,lcAlias) = ; REPL("1",FCOUNT(lcAlias)+1), ; 0,1) ENDCASE ENDIF CASE INLIST(liBufferMode, DB_BUFLOCKTABLE, DB_BUFOPTTABLE) * table buffering DO CASE CASE liChangeMode = 1 * see notes above IF CURSORGETPROP("SourceType", lcAlias) = 3 liAction = GETNEXTMODIFIED(0,lcAlias) ELSE liCurrentRecord = IIF(EOF(lcAlias),0, ; RECNO(lcAlias)) liRecord = GETNEXTMODIFIED(0,lcAlias) liAction = 0 lcFieldList =","+UPPER(CURSORGETPROP("UpdatableFieldList",lcAlias))+"," lcFieldList = STRTRAN(lcFieldList,", ", ",") DO WHILE liRecord # 0 AND liAction = 0 GO liRecord IN (lcAlias) lcFieldStates = GETFLDSTATE(-1,lcAlias) IF lcFieldStates = REPL("1",FCOUNT(lcAlias)+1) liAction = 0 ELSE liAction = 1 IF LEFT(lcFieldStates,1) = "1" AND ; CURSORGETPROP("SourceType", lcAlias) # 3 liAction = 0 FOR liField = 1 TO FCOUNT(lcAlias) IF SUBSTR(lcFieldStates,liField+1,1) # "1" AND ; (","+UPPER(FIELD(liField,lcAlias))+"," $ ; lcFieldList) liAction = 1 EXIT ENDIF ENDFOR ENDIF ENDIF liRecord = GETNEXTMODIFIED(liRecord,lcAlias) ENDDO IF liCurrentRecord # RECNO(lcAlias) IF liCurrentRecord = 0 GO BOTTOM IN (lcAlias) IF RECCOUNT(lcAlias) > 0 SKIP IN (lcAlias) ENDIF ELSE GO liCurrentRecord IN (lcAlias) ENDIF ENDIF ENDIF CASE liChangeMode = 2 * see notes above IF CURSORGETPROP("SourceType", lcAlias) = 3 OR ; CURSORGETPROP("SendUpdates", lcAlias) liAction = GETNEXTMODIFIED(0,lcAlias) ENDIF OTHERWISE * original code applies: liAction = GETNEXTMODIFIED(0,lcAlias) ENDCASE OTHERWISE * no buffering -- or (god forbid) * an unknown return that hasn't been * caught by assertion during testing * do nothing ENDCASE IF liAction # 0 * changes have occurred in at least one table in the system EXIT ENDIF ENDFOR IF TYPE("toSession.DataSessionID") = "N" THIS.RestoreSessionID() ENDIF RETURN liAction # 0 ENDPROC PROCEDURE dataflush LOCAL loActiveControl, lcAlias IF TYPE("_SCREEN.ActiveForm.ActiveControl") # "O" RETURN ENDIF loActiveControl = THIS.GetActiveControlRef(_SCREEN.ActiveForm.ActiveControl) IF TYPE("loActiveControl.Value") # "U" AND ; TYPE("loActiveControl.ControlSource") # "U" AND ; TYPE(loActiveControl.ControlSource) # "U" AND ; (TYPE("loActiveControl.ReadOnly") = "U" OR ; NOT loActiveControl.ReadOnly) AND ; (NOT EVAL(loActiveControl.Controlsource) == loActiveControl.Value) IF "." $ loActiveControl.ControlSource lcAlias = LEFT(loActiveControl.ControlSource,AT(".",loActiveControl.ControlSource) - 1) ELSE lcAlias = ALIAS() ENDIF IF INLIST(CURSORGETPROP("BUFFERING",lcAlias),DB_BUFLOCKRECORD,DB_BUFLOCKTABLE) ; AND NOT ISRLOCKED(RECNO(lcAlias),lcAlias) IF NOT RLOCK(RECNO(lcAlias),lcAlias) * help ! pessimistic locking in effect * and somebody else actually has this record * locked! we shouldn't be editing this record... * actually this should never happen! = MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ; MB_OK+MB_ICONSTOP,; THIS.GetMessageBoxTitle()+": "+PROPER(lcAlias)) RETURN .F. ELSE * this was a speculative lock only * if it was a view it really isn't * a problem to have taken this lock * briefly, although it didn't help either UNLOCK RECORD RECNO(lcAlias) IN (lcAlias) ENDIF ENDIF loActiveControl.Value = loActiveControl.Value ELSE * no flush required ENDIF ENDPROC PROCEDURE getactivecontrolref LPARAMETERS toActiveControl LOCAL loRealActiveControl, liThisColumn, loColumn IF TYPE("toActiveControl.BaseClass")# "C" * redundant in DataFlush() call, but could be called from elsewhere RETURN .F. ENDIF IF UPPER(toActiveControl.BaseClass) == "GRID" liThisColumn = toActivecontrol.ActiveColumn FOR EACH loColumn IN toActiveControl.Columns IF loColumn.ColumnOrder # liThisColumn LOOP ENDIF IF NOT (loColumn.ReadOnly and loColumn.Bound) loRealActiveControl = EVAL("loColumn."+loColumn.CurrentControl) ENDIF EXIT ENDFOR ELSE loRealActiveControl = toActiveControl ENDIF RETURN loRealActiveControl ENDPROC PROCEDURE getmessageboxtitle RETURN DATA_MESSAGEBOX_TITLE_LOC ENDPROC PROCEDURE restoresessionid IF SET("DATASESSION") # THIS.iSavedSessionID SET DATASESSION TO THIS.iSavedSessionID ENDIF ENDPROC PROCEDURE setsessionid LPARAMETERS tiSession IF VARTYPE(tiSession) = "N" AND SET("DATASESSION") # tiSession THIS.iSavedSessionID = SET("DATASESSION") SET DATASESSION TO tiSession ENDIF ENDPROC PROCEDURE queryunload LPARAMETERS tlDataChangeAlreadyConfirmed, toSession, tlNoShow ASSERT VARTYPE(tlDataChangeAlreadyConfirmed) = "L" ASSERT TYPE("toSession.DataSessionID") = "N" OR ; TYPE("_SCREEN.ActiveForm") = "O" ASSERT VARTYPE(tlNoShow) = "L" LOCAL liResult, llChange, loSession IF TYPE("toSession.DataSessionID") = "N" loSession = toSession ELSE loSession = _SCREEN.ActiveForm ENDIF THIS.SetSessionID(loSession.DataSessionID) llChange = tlDataChangeAlreadyConfirmed OR THIS.DataChanged(loSession) IF llChange * changes have been detected somewhere... IF PEMSTATUS(loSession,"Show",5) AND NOT tlNoShow loSession.Show() ENDIF liResult = ; MESSAGEBOX( DATA_SAVE_BEFORE_CLOSE_LOC ,; MB_ICONEXCLAMATION + MB_YESNOCANCEL, ; THIS.GetMessageBoxTitle()) ELSE liResult = IDNO ENDIF DO CASE CASE liResult = IDYES THIS.Update(.T.,.T.,loSession) CASE liResult = IDNO AND llChange THIS.Revert(.T.,.T.,loSession) OTHERWISE * there were data changes and they chose to cancel ENDCASE THIS.RestoreSessionID() RETURN (liResult # IDCANCEL) ENDPROC PROCEDURE Error LPARAMETERS nError, cMethod, nLine LOCAL laErrors[1] =AERROR(laErrors) THIS.lSuccess = .F. IF UPPER(cMethod)=="UPDATE" IF (INLIST(nError,1580,1581,1582,1583,1531,1539,1590,; 1546, 1547,111,1157,1579,1598, 1647, 1504, 1887) ; OR ; INLIST(nError, 2007, 2008, 2010,2011,2015,1491, 1996, 1589, ; 1864,1865,1879,1884,1886, 1712,2014,1594, 1588 ) ; OR ; INLIST(nError,1548,1777,1495)) ; && leaving room for more... AND NOT ISNULL(laErrors[1,4]) * rule failure,trigger, transaction failure, * and some additional problems * that the programmer * should see and handle in the rule code or other * work in the form itself, it is not something that * should be resolved by the user at runtime! DODEFAULT(nError,cMethod,nLine) ELSE * otherwise we want to treat this as an error * that Update handles internally. * this may not be important ENDIF ELSE DODEFAULT(nError, cMethod, nLine) ENDIF ENDPROC PROCEDURE Init IF NOT DODEFAULT() RETURN .F. ENDIF THIS.iSavedSessionID = SET("DATASESSION") ENDPROC  hccurrentmessage MESSAGE() of current error ccurrentmethod Method or procedure where error occurred, as passed to Handle(). icurrenterror Error number for current error. icurrentline Line where current error occurred. ccurrentclass The error classification that the error object gives this particular error number. lserver Checks _VFP.StartMode to see whether any sort of modal feedback should be avoided. clogalias Alias under which the error log is opened. See SetLog(). clogdbf Fully qualified name of current error table on disk. See SetLog(). ccurrenterrorparam SYS(2018) of current error lusercancelled Allows the outside program to cleanup and do whatever is necessary before release. *handle Main routine to handle error. ^aerrorclass[1,3] Error numbers by classification for evaluation of type and severity. ^aerrors[1,6] *oktoreport Abstract method to evaluate error whether to report error. *fillarrays Fills error classification array (aErrorClass) first time, and current error array (aErrors) for each error that occurs. Bails if conditions are so severe (memory errors) that further processing is undesirable. *istrivial Whether error is a trivial type error. *isfatal Whether error is a fatal type error. *oktocontinue Abstract method to evaluate error whether to continue program execution. *logerrorreport If lServer is .T. or user indicates logging is desired, opens error log and logs the error. *displayerrorlog Displays error log. *geterrorattribute Returns appropriate information from aErrorClass array for a given error number. *getmessageboxtitle This is really meant for your subclass or instance to fill out with app-specific information, so that all user feedback (WAIT WINDOW NOWAITs and MESSAGEBOX()) by the error object matches your app properly. *setlog Evaluates log table name and alias, attempts to open and validate the table, creates new alias and log table name on the fly if anything goes wrong. *isgooderrorlog Validates error log *userhandleserror Gives user choices about whether to go on with the app after an error. *usercancelled Returns whether user opted to cancel after the current error. *filllogrecord Writes error information to the log. *doerrorlogui Called by DisplayErrorLog for actual UI display after setup. The simple default behavior here (BROWSE NOWAIT) is meant to be overridden by application-specific behavior. *recordservererror Establishes a consistent method for logging feedback which would ordinarily go to UI, for use in servers *isdisallowedserveraction Tells whether the error is caused by an attempt to execute UI or other disallowed action from a server 1 11%+80vL-UHTCETC]&TCCN6TC_&TCCN6T T - C T C ,%Ca Ca Ca  A%C C%C= CUTIERRORTCMETHODTILINETHISCCURRENTMESSAGECCURRENTERRORPARAM ICURRENTERRORCCURRENTMETHOD ICURRENTLINE CCURRENTCLASSLUSERCANCELLED FILLARRAYSGETERRORATTRIBUTEISDISALLOWEDSERVERACTIONISFATAL ISTRIVIAL OKTOREPORTLOGERRORREPORT OKTOCONTINUEUSERHANDLESERRORU%CCL"Tmemory]TA/21/22/43/1012/1149/1150/1151/1201/1202/1507/1600/1809/1986/2000/ T/C_/%C TaCz3% !CTHIS.aErrorClass[2,1]bC !Tindex8T/5/19/20/114/1103/1141/1707/ Tdisk*T/56/1410/1157/ TfileT5/1/6/7/15/41/50/54/55/102/110/111/115/116/117/119/1204/121/127/202/255/266/297/356/392/1102/1104/1105/11082/1111/1112/1113/1115/1126/1166/1131/1167/1168/1169-/1243/1245/1246/1294/1298/1509/1510/1637/1643/1644/1705/1708/#Tcommand,T/1405/1411/1412/ Tlock?T#/3/108/109/130/1502/1503/1106/1585/"ToutputCT'/216/221/222/223/227/228/332/1002/1153/4Tprogram or resource filePT4/67/91/1161/1178/1193/1194/1195/1196/1296/1309/1338/!T print>T "/124/125/1910/1524/1643/1644/1717/#T activexvT A/1420/1421/1422/1423/1424/1426/1427/1428/1429/1431/1434/1436/1508/1440/2003/1782/2021/T sql^T B/1465/1466/1471/1472/1474/1475/1476/1477/1864/1865/1802/1890/1845/"T cursorwT [/1467/1468/1473/1478/1479/1489/1491/1492/1493/1494/1495/1498/1499/1542/1546/1547/1548/1568/ T odbcrT V/1480/1481/1482/1483/1484/1485/1486/1487/1496/1497/1522/1523/1525/1526/1527/1528/1530/0Trelational integrityOT3/1539/1555/1567/1879/1881/1882/1883/1884/1886/1887/'T datasession,T/1540/1545/1549/)T offline views;T/2007/2008/2010/2011/2015/2018/ B UTHIS AERRORCLASS LCERRSTRINGLLBAIL ICURRENTERRORAERRORS  T/TC///print//lock/%  HoM printiT:The printer or printer driver you require is not available:C C "" lockMDTA file or record is unavailable:C C % XCC C 2Please handle this problem, or wait and try again.0Cx BU TLWANTDIALOG LLISTRIVIAL LCMESSAGETHIS CCURRENTCLASSCCURRENTMESSAGELSERVERGETMESSAGEBOXTITLE  TMTC///memory//disk//program or resource file/% TSerious error of class: CfC XThe application will exit, and cannot add information about this error to the error log.C C C C]C C #C_ , C_C C ""% C ICC C #Please note this error information.C x BU TLWANTDIALOG LLISFATAL LCMESSAGETHIS CCURRENTCLASS ICURRENTERRORCCURRENTMETHOD ICURRENTLINECCURRENTMESSAGELSERVERRECORDSERVERERRORGETMESSAGEBOXTITLEU`T""C C (C_)CC ()6C , C_C C]%qCAn error has occurred:C C C C "Record details in error log files?Cx Y% 6R,:C C C R U LCMESSAGETHISCCURRENTMESSAGE ICURRENTERRORCCURRENTERRORPARAMCCURRENTMETHOD ICURRENTLINELSERVERGETMESSAGEBOXTITLESETLOG FILLLOGRECORD. TCW C H-' C C % 5CThe error log is not available.0Cx CN% 3CThe error log has no records.0Cx2' FC FULISELECTTHISSETLOG CLOGALIASLSERVERGETMESSAGEBOXTITLE DOERRORLOGUId 2C$CNCCͫ  CCCNC  H CT/C _/ CNT/C_/2T/C/%C T/ TTCC H[ Cz T CNIYTC~ CDTT O T2(CT%CPTC! BU TICOLUMNTVERRNOTHIS AERRORCLASS LCERRSTRINGLICOLUMNLIINDEXLVRETURNLCTYPE ICURRENTERRORB Error MessageU; 1%C  C C CBa%CCC TC%C C T%CTEC]+CTEC]T%C?TC& HT CCC TC C TC2T errorlog.dbf%C.T.dbfTCC@%C 0%CC] Q$%CC %CQCC , TCWF(h1 T M MQ FBU TCTABLENAMETCALIASTHIS CLOGALIASISGOODERRORLOGLCALIAS LCTABLENAMELISELECTCLOGDBFSETLOGERRSTAMPLISTING USERNOTES C CBCCfERRSTAMPCCfLISTING CCf USERNOTES (CCCTMM UTCALIASATEMP  H 1 T ChTCContinue Executing Program?C C Choose: C C OK to Continue the programC "CANCEL to Exit program completely.1Cx2TCContinue Executing Program?C C Choose: C C YES to Continue the programC NO to Suspend C "CANCEL to Exit program completely.3Cx H CB L2TaU LICONTINUETHISLSERVERGETMESSAGEBOXTITLELUSERCANCELLED BUTHISLUSERCANCELLED#rErrstampC TCWTC DATASESSIONv FTError # C_%C  T class: &TC Program  &TC Message  %C @T ( )(TC Line # C _ T&%C_SCREEN.ActiveFormbO(TC Active: 9 4%C _SCREEN.ActiveForm.ActiveControlbO$T (9 ) H04 C _SCREEN.ActiveForm.DataSessionIDbNvT9 ; C'_SCREEN.ActiveForm.Parent.DataSessionIDbNT9 2%TC Session C_> TC DiskSpc CC(_9TC Screen CC%_ by CC%_"TC OS CJ%TC Vers(1) Ch'TC Vers(2) CCh_%TC Vers(3) Ch'TC SMode CC_KTC (1016) CCC]g _ user object memory usedITC (1001) CCC]g _ pool available memory%TC CPU C]&TC Video C]#TC C C=2Q1TC  Calling Chain:> TTC &+CC] C]Ct TC C]TTC C=2Q#TC C C=2Q7TC  CONFIG file: C]%CC]0#TC C=2QC >C]5T NOT AVAILABLEC C=2QC >TC C C=2QHTC 1 Status listing of Current Data Session #TC C=2QC >#TC]\C].tmp+C0#TC]\C].tmp% F  G(+(9%< FP G( T>C C=2QC  Memory listingC C=2QC +(9  FUTHIS CLOGALIAS LCERRDATA LIERRLEVELLISELECT LISESSION LIFORMSESSION ICURRENTERROR CCURRENTCLASSCCURRENTMETHODCCURRENTMESSAGECCURRENTERRORPARAM ICURRENTLINE ACTIVEFORMNAME ACTIVECONTROL DATASESSIONIDPARENTLISTING STARTMODE%%  :UTCALIASTHISLSERVERgTC_ C#rErrstampC>U TCMESSAGE LCMESSAGETHISSETLOG CLOGALIASLISTINGIN=%* C    Ta %KCC C C_C  C C _ BU TLWANTRECORDLLDISALLOWEDSERVERACTIONTHISLSERVER ICURRENTERROR STARTMODERECORDSERVERERRORCCURRENTMESSAGECCURRENTERRORPARAMCCURRENTMETHOD ICURRENTLINEgTC DATASESSIONv G(%CLQ G( CU LISESSIONTHIS CLOGALIAS%setlogC@8TdError in error handler:C #C_C  , C_C UNERRORCMETHODNLINETHISCLOGDBFNAMECCURRENTMESSAGEhandle, oktoreport fillarrays istrivialt isfatal oktocontinueblogerrorreportidisplayerrorlogdgeterrorattributegetmessageboxtitlesetlogisgooderrorloguserhandleserror] usercancelled filllogrecord doerrorlogui'recordservererror(isdisallowedserveraction(Destroy*Error*11a!aBBC53"AA2bE1!1A1b!q!qD2qBEBAB2qC)AC23qHAQB3qTAb4A1B4$rQAA!q1!BAAA5a2qAAA"QQAA#1!AqQABB2B!AAAAB2q3q13 ARAAAJ521r1Aaa1AbAAAA!RBAR!QqQqQa1aA1q!1!QA121AAAD5qaA2qq1q3qqAA2q!I2DA23I8j;C<}TMbpcnF n $$%D:%2-GW-t..222 3CPC[DQUDOEY\~EGbfGIuoIQK)1K\PROCEDURE handle LPARAMETERS tiError, tcMethod, tiLine THIS.cCurrentMessage = MESSAGE() THIS.cCurrentErrorParam = SYS(2018) THIS.iCurrentError = IIF(VARTYPE(tiError) # "N",0,tiError) THIS.cCurrentMethod = TRANSFORM(tcMethod) THIS.iCurrentLine = IIF(VARTYPE(tiLine) # "N",0,tiLine) THIS.cCurrentClass = "" THIS.lUserCancelled = .F. && it's possible && for an outside program to ignore a previous CANCEL instruction THIS.FillArrays() * note: FillArrays() does an early bail for memory * errors,which will be messaged by THIS.IsFatal() below * see FillArrays() for structure * of aErrorClass array -- * GetErrorAttribute * gets a particular element by looking * up error numbers in the first array column and specifying * what column of the array is needed. This column * is passed as GetErrorAttribute's first parameter * (you can also pass a second parameter containing * a particular error number to look up -- this defaults * to the iCurrentError contents) THIS.cCurrentClass = THIS.GetErrorAttribute(2) * for example, * THIS.cCurrentLevel = THIS.GetErrorAttribute(3) * for a property that used a third column of * the array to store some error severity classification system IF NOT (THIS.IsDisallowedServerAction(.T.) OR ; THIS.IsFatal(.T.) OR ; THIS.IsTrivial(.T.)) IF THIS.OKToReport() THIS.LogErrorReport() ENDIF IF THIS.OKToContinue() THIS.UserHandlesError() ENDIF ENDIF ENDPROC PROCEDURE oktoreport * abstract in the base ENDPROC PROCEDURE fillarrays IF VARTYPE(THIS.aErrorClass[1]) ="L" * first time through THIS.aErrorClass[1,2] = "memory" THIS.aErrorClass[1,1] = "/21/22/43/1012/1149/1150/1151/1201/1202/1507/1600/1809/1986/2000/" ENDIF LOCAL lcErrString, llBail lcErrString = "/"+TRANSFORM(THIS.iCurrentError)+"/" IF lcErrString $ THIS.aErrorClass[1,1] llBail = .T. ELSE =AERROR(THIS.aErrors) ENDIF IF (NOT llBail) AND (TYPE("THIS.aErrorClass[2,1]") # "C") DIME THIS.aErrorClass[16,2] * note: you can add more columns for more error attributes, * for example a severity gauge for different classes * or other error class groupings THIS.aErrorClass[2,2] = "index" THIS.aErrorClass[2,1] = "/5/19/20/114/1103/1141/1707/" THIS.aErrorClass[3,2] = "disk" THIS.aErrorClass[3,1] = "/56/1410/1157/" THIS.aErrorClass[4,2] = "file" THIS.aErrorClass[4,1] = "/1/6/7/15/41/50/54/55/102/110/111/115/116/117/119/120"+; "/121/127/202/255/266/297/356/392/1102/1104/1105/1108"+; "/1111/1112/1113/1115/1126/1166/1131/1167/1168/1169"+; "/1243/1245/1246/1294/1298/1509/1510/1637/1643"+; "/1644/1705/1708/" THIS.aErrorClass[5,2] = "command" THIS.aErrorClass[5,1] = "/1405/1411/1412/" THIS.aErrorClass[6,2] = "lock" THIS.aErrorClass[6,1] = "/3/108/109/130/1502/1503/1106/1585/" THIS.aErrorClass[7,2] = "output" THIS.aErrorClass[7,1] = "/216/221/222/223/227/228/332/1002/1153/" THIS.aErrorClass[8,2] = "program or resource file" THIS.aErrorClass[8,1] = "/67/91/1161/1178/1193/1194/1195/1196/1296/1309/1338/" THIS.aErrorClass[9,2] = "print" THIS.aErrorClass[9,1] = "/124/125/1910/1524/1643/1644/1717/" THIS.aErrorClass[10,2] = "activex" THIS.aErrorClass[10,1] = "/1420/1421/1422/1423/1424/1426/1427/1428/1429/1431/1434/1436/1508"+; "/1440/2003/1782/2021/" THIS.aErrorClass[11,2] = "sql" THIS.aErrorClass[11,1] = "/1465/1466/1471/1472/1474/1475/1476/1477/1864/1865/1802/1890/1845/" THIS.aErrorClass[12,2] = "cursor" THIS.aErrorClass[12,1] = "/1467/1468/1473/1478/1479/1489/1491/1492/1493/1494/1495/1498/1499/1542/1546/1547/1548/1568/" THIS.aErrorClass[13,2] = "odbc" THIS.aErrorClass[13,1] = "/1480/1481/1482/1483/1484/1485/1486/1487/1496/1497/1522/1523/1525/1526/1527/1528/1530/" THIS.aErrorClass[14,2] = "relational integrity" THIS.aErrorClass[14,1] = "/1539/1555/1567/1879/1881/1882/1883/1884/1886/1887/" THIS.aErrorClass[15,2] = "datasession" THIS.aErrorClass[15,1] = "/1540/1545/1549/" THIS.aErrorClass[16,2] = "offline views" THIS.aErrorClass[16,1] = "/2007/2008/2010/2011/2015/2018/" * THIS.aErrorClass[17,2] = "database" * THIS.aErrorClass[17,1] = "/1529/1531/1534/1535/1536/1537/1538/1541/1542/1550/1551/1552/1553/1557/1558/1561/1562/1563/1564/1565/1566/1569/1570/" ENDIF RETURN (NOT llBail) ENDPROC PROCEDURE istrivial LPARAMETERS tlWantDialog LOCAL llIsTrivial, lcMessage lcMessage = "" llIsTrivial = INLIST("/"+THIS.cCurrentClass+"/", ; "/print/", ; "/lock/") IF llIsTrivial AND tlWantDialog * messageboxes DO CASE CASE THIS.cCurrentClass == "print" lcMessage = ERROR_PRINT_LOC + ":"+ ; CHR(13)+CHR(13)+; ["]+THIS.cCurrentMessage+["] CASE THIS.cCurrentClass == "lock" * should not happen unless SET REPROCESS * is not properly set lcMessage = ERROR_LOCK_LOC + ":"+ ; CHR(13)+CHR(13)+; THIS.cCurrentMessage ENDCASE IF NOT THIS.lServer =MESSAGEBOX(lcMessage+CHR(13)+CHR(13)+ ; ERROR_USER_FIX_LOC,; MB_ICONEXCLAMATION, ; THIS.GetMessageBoxTitle()) ENDIF ENDIF RETURN llIsTrivial ENDPROC PROCEDURE isfatal LPARAMETERS tlWantDialog LOCAL llIsFatal, lcMessage lcMessage = "" llIsFatal = INLIST("/"+THIS.cCurrentClass+"/", ; "/memory/", ; "/disk/", ; "/program or resource file/" ) IF llIsFatal AND tlWantDialog lcMessage = ERROR_SERIOUS_CLASS_LOC + ": " + UPPER(THIS.cCurrentClass) + CHR(13) +; ERROR_CANNOT_BE_LOGGED_LOC + CHR(13)+ ; CHR(13)+CHR(13)+; SYS(16,0)+ ; CHR(13)+ CHR(13)+ ; "#"+TRANSFORM(THIS.iCurrentError)+" "+ ; THIS.cCurrentMethod+", "+TRANSFORM(THIS.iCurrentLine) + ; CHR(13)+CHR(13)+ ; ["]+THIS.cCurrentMessage+["] IF THIS.lServer THIS.RecordServerError(lcMessage) ELSE =MESSAGEBOX(lcMessage+CHR(13)+CHR(13)+ ; ERROR_USER_NOTE_LOC, ; MB_ICONSTOP, ; THIS.GetMessageBoxTitle()) ENDIF ENDIF RETURN llIsFatal ENDPROC PROCEDURE oktocontinue * abstract in the base ENDPROC PROCEDURE logerrorreport LOCAL lcMessage lcMessage = ["]+THIS.cCurrentMessage +["] + CHR(13)+CHR(13)+ ; "("+TRANSFORM(THIS.iCurrentError)+")"+ ; IIF(EMPTY(THIS.cCurrentErrorParam),"",; " ("+THIS.cCurrentErrorParam+")" )+CHR(13)+ ; THIS.cCurrentMethod+", "+TRANSFORM(THIS.iCurrentLine)+ CHR(13)+; SYS(16,0) IF THIS.lServer OR ; MESSAGEBOX(ERROR_OCCURRED_LOC+":"+CHR(13)+CHR(13)+; lcMessage+ CHR(13)+CHR(13)+ ; ERROR_LOG_LOC, ; MB_ICONSTOP+MB_YESNO, ; THIS.GetMessageBoxTitle()) ; = IDYES IF NOT THIS.lServer WAIT WINDOW NOWAIT LEFTC(lcMessage,254) ENDIF THIS.SetLog() THIS.FillLogRecord() WAIT CLEAR ENDIF ENDPROC PROCEDURE displayerrorlog LOCAL liSelect liSelect = SELECT() THIS.SetLog() DO CASE CASE (EMPTY(THIS.cLogAlias) OR NOT USED(THIS.cLogAlias)) IF NOT THIS.lServer MESSAGEBOX(ERROR_LOG_UNAVAILABLE_LOC,; MB_ICONEXCLAMATION,; THIS.GetMessageBoxTitle()) ENDIF CASE RECCOUNT(THIS.cLogAlias) = 0 IF NOT THIS.lServer MESSAGEBOX(ERROR_LOG_EMPTY_LOC,; MB_ICONEXCLAMATION,; THIS.GetMessageBoxTitle()) ENDIF OTHERWISE SELECT (THIS.cLogAlias) THIS.DoErrorLogUI(THIS.cLogAlias) SELECT (liSelect) ENDCASE ENDPROC PROCEDURE geterrorattribute LPARAMETER tiColumn, tvErrNo ASSERT EMPTY(tiColumn) OR ; (VARTYPE(tiColumn) = "N" AND ; BETWEEN(tiColumn,1,ALEN(THIS.aErrorClass,2))) ASSERT EMPTY(tvErrNo) OR INLIST(VARTYPE(tvErrNo),"N","C") LOCAL lcErrString, liColumn, liIndex, lvReturn, lcType DO CASE CASE EMPTY(tvErrNo) lcErrString = "/"+TRANSFORM(THIS.iCurrentError)+"/" CASE VARTYPE(tvErrNo) = "N" lcErrString = "/"+TRANSFORM(tvErrNo)+"/" OTHERWISE lcErrString = "/"+ALLTR(tvErrNo)+"/" ENDCASE IF EMPTY(tiColumn) * return the first column, error number string liColumn = 1 ELSE liColumn = tiColumn ENDIF lcType = VARTYPE(THIS.aErrorClass[1,liColumn]) DO CASE CASE lcType = "C" lvReturn = "" CASE INLIST(lcType,"N","I","Y") lvReturn = NTOM(0) CASE INLIST(lcType,"D","T") lvReturn = {} CASE lcType = "O" lvReturn = .NULL. OTHERWISE * lvReturn = .F. ENDCASE FOR liIndex = 1 TO ALEN(THIS.aErrorClass,1) IF lcErrString $ THIS.aErrorClass[liIndex,1] lvReturn = THIS.aErrorClass[liIndex,liColumn] EXIT ENDIF ENDFOR RETURN lvReturn ENDPROC PROCEDURE getmessageboxtitle RETURN ERROR_MESSAGEBOX_TITLE_LOC ENDPROC PROCEDURE setlog LPARAMETERS tcTableName, tcAlias IF (NOT EMPTY(THIS.cLogAlias)) AND ; USED(THIS.cLogAlias) AND ; THIS.IsGoodErrorLog(THIS.cLogAlias) RETURN .T. ENDIF LOCAL lcAlias, lcTableName, liSelect IF VARTYPE(tcAlias) = "C" AND NOT EMPTY(tcAlias) lcAlias = ALLTR(tcAlias) IF USED(lcAlias) AND THIS.IsGoodErrorLog(lcAlias) THIS.cLogAlias = lcAlias ENDIF ENDIF IF EMPTY(THIS.cLogAlias) lcAlias = "E"+SYS(2015) DO WHILE USED(lcAlias) lcAlias = "E"+SYS(2015) ENDDO THIS.cLogAlias = lcAlias ENDIF * now for the table name: IF USED(THIS.cLogAlias) lcTableName = DBF(lcAlias) ELSE DO CASE CASE VARTYPE(tcTableName) = "C" AND NOT EMPTY(tcTableName) lcTableName = ALLTR(tcTableName) CASE NOT EMPTY(THIS.cLogDBF) lcTableName = ALLTR(THIS.cLogDBF) OTHERWISE lcTableName = "errorlog.dbf" ENDCASE IF AT(".",lcTableName) = 0 lcTableName = lcTableName+".dbf" ENDIF ENDIF THIS.cLogDBF = LOWER(FULLPATH(lcTableName)) IF NOT USED(THIS.cLogAlias) IF NOT EMPTY(SYS(2000,THIS.cLogDBF)) USE (THIS.cLogDBF) AGAIN SHARED ALIAS (THIS.cLogAlias) IN 0 IF EMPTY(THIS.cLogDBF) ; OR NOT THIS.IsGoodErrorLog(THIS.cLogAlias) IF USED(THIS.cLogAlias) USE IN (THIS.cLogAlias) ENDIF * recursive call with new, temporary filename: THIS.SetLog(FULLPATH(THIS.cLogAlias), THIS.cLogAlias) ENDIF ELSE liSelect = SELECT() SELE 0 * v-darylm CREATE TABLE (THIS.cLogDBF) FREE ; (errstamp t, ; listing m,; usernotes m) *!* CREATE TABLE (THIS.cLogDBF) ; *!* (errstamp t, ; *!* listing m,; *!* usernotes m) USE (THIS.cLogDBF) AGAIN SHARED ALIAS (THIS.cLogAlias) SELECT (liSelect) ENDIF ENDIF RETURN ENDPROC PROCEDURE isgooderrorlog LPARAMETERS tcAlias ASSERT USED(tcAlias) LOCAL ARRAY aTemp[1] =AFIELDS(aTemp,tcAlias) RETURN UPPER(aTemp(1,1))== "ERRSTAMP" AND ; UPPER(aTemp(2,1))== "LISTING" AND ; UPPER(aTemp(3,1))== "USERNOTES" AND ; aTemp(1,2)+aTemp(2,2)+aTemp(3,2)=="TMM" ENDPROC PROCEDURE userhandleserror LOCAL liContinue DO CASE CASE THIS.lServer liContinue = IDYES CASE VERSION(2) = 0 liContinue = MESSAGEBOX( ERROR_USEREND_LOC,; MB_ICONEXCLAMATION+MB_OKCANCEL, ; THIS.GetMessageBoxTitle()) OTHERWISE liContinue = MESSAGEBOX(ERROR_DEVEND_LOC, ; MB_ICONEXCLAMATION+MB_YESNOCANCEL, ; THIS.GetMessageBoxTitle()) ENDCASE DO CASE CASE INLIST(liContinue,IDYES, IDOK) RETURN CASE liContinue = IDNO DEBUG SUSPEND OTHERWISE THIS.lUserCancelled = .T. * at this point in an object method, a CANCEL may be * the same as a RETURN. The owning object * has to decide what to do. If you do a CANCEL * here it will have the effect of making it * difficult for the container to RELEASE properly. * This is especially a problem if the error * has been invoked by the ON ERROR handler, because * the ON... interrupt can take you back to anywhere. ENDCASE ENDPROC PROCEDURE usercancelled RETURN THIS.lUserCancelled ENDPROC PROCEDURE filllogrecord INSERT INTO (THIS.cLogAlias) ("Errstamp") VALUES (DATETIME()) LOCAL lcErrData, liErrLevel, liSelect, liSession, liFormSession liSelect = SELECT() liSession = SET("DATASESSION") SELECT (THIS.cLogAlias) * create listing memo field from chunks of data -- * do a couple of REPLACEs so that less memory is * used for each step of this process lcErrData = "Error # "+TRANSFORM(THIS.iCurrentError) IF NOT EMPTY(THIS.cCurrentClass) lcErrData = lcErrData+ " class: "+THIS.cCurrentClass ENDIF lcErrData = lcErrData+CHR(13)+"Program "+ THIS.cCurrentMethod lcErrData = lcErrData+CHR(13)+"Message "+ THIS.cCurrentMessage IF NOT EMPTY(THIS.cCurrentErrorParam) lcErrData = lcErrData+ " (" +THIS.cCurrentErrorParam+")" ENDIF lcErrData = lcErrData+CHR(13)+"Line # "+TRANSFORM(THIS.iCurrentLine) liFormSession = liSession IF TYPE("_SCREEN.ActiveForm") = "O" lcErrData = lcErrData+CHR(13)+"Active: "+_SCREEN.ActiveForm.Name IF TYPE("_SCREEN.ActiveForm.ActiveControl") = "O" lcErrData = lcErrData+ " ("+_SCREEN.ActiveForm.ActiveControl.Name+")" ENDIF DO CASE CASE TYPE("_SCREEN.ActiveForm.DataSessionID") = "N" liFormSession = _SCREEN.ActiveForm.DataSessionID CASE TYPE("_SCREEN.ActiveForm.Parent.DataSessionID") = "N" * formset liFormSession = _SCREEN.ActiveForm.Parent.DataSessionID OTHERWISE * can be a defined window or modi memo or whatever ENDCASE ENDIF lcErrData = lcErrData+CHR(13)+"Session "+TRANSFORM(liFormSession) REPLACE listing WITH lcErrData ADDITIVE lcErrData = CHR(13)+"DiskSpc "+TRANSFORM(DISKSPACE()) lcErrData = lcErrData+CHR(13)+"Screen "+TRANSFORM(SYSMETRIC(2))+" by "+TRANSFORM(SYSMETRIC(1)) lcErrData = lcErrData+CHR(13)+"OS "+OS() lcErrData = lcErrData+CHR(13)+"Vers(1) "+VERSION(1) lcErrData = lcErrData+CHR(13)+"Vers(2) "+TRANSFORM(VERSION(2)) lcErrData = lcErrData+CHR(13)+"Vers(3) "+VERSION(3) lcErrData = lcErrData+CHR(13)+"SMode "+TRANSFORM(_VFP.StartMode) lcErrData = lcErrData+CHR(13)+"(1016) "+TRANSFORM(VAL(SYS(1016))/1024)+" user object memory used" lcErrData = lcErrData+CHR(13)+"(1001) "+TRANSFORM(VAL(SYS(1001))/1024)+" pool available memory" lcErrData = lcErrData+CHR(13)+"CPU "+ SYS(17) lcErrData = lcErrData+CHR(13)+"Video "+SYS(2006) lcErrData = lcErrData+CHR(13)+CHR(13)+REPLICATE("=",50) lcErrData = lcErrData+CHR(13)+" Calling Chain:" REPLACE listing WITH lcErrData ADDITIVE liErrLevel = 1 lcErrData = CHR(13) DO WHILE NOT EMPTY(SYS(16,liErrLevel)) AND NOT SYS(16,liErrLevel) == PROGRAM() lcErrData = lcErrData + CHR(13)+SYS(16,liErrLevel) liErrLevel= liErrLevel+1 ENDDO lcErrData = lcErrData+CHR(13)+REPLICATE("=",50) lcErrData = lcErrData+CHR(13)+CHR(13)+REPLICATE("=",50) lcErrData = lcErrData+CHR(13)+" CONFIG file: "+SYS(2019) IF FILE(SYS(2019)) lcErrData = lcErrData + CHR(13)+REPLICATE("=",50)+CHR(13) REPLACE listing WITH lcErrData ADDITIVE APPEND MEMO listing FROM (SYS(2019)) && ADDITIVE by default ELSE lcErrData = lcErrData + " NOT AVAILABLE"+CHR(13)+REPLICATE("=",50)+CHR(13) REPLACE listing WITH lcErrData ADDITIVE ENDIF lcErrData = CHR(13)+CHR(13)+REPLICATE("=",50) lcErrData = lcErrData+CHR(13)+" Status listing of Current Data Session " lcErrData = lcErrData+CHR(13)+REPLICATE("=",50)+CHR(13) REPLACE listing WITH lcErrData ADDITIVE lcErrData = SYS(2023)+"\"+SYS(3)+".tmp" DO WHILE FILE(lcErrData) lcErrData = SYS(2023)+"\"+SYS(3)+".tmp" ENDDO IF liSession = liFormSession SELECT (liSelect) ELSE SET DATASESSION TO (liFormSession) ENDIF LIST STATUS TO (lcErrData) NOCONSOLE IF liSession = liFormSession SELECT (THIS.cLogAlias) ELSE SET DATASESSION TO (liSession) ENDIF APPEND MEMO listing FROM (lcErrData) ERASE (lcErrData) REPLACE listing WITH CHR(13)+REPLICATE("=",50)+CHR(13)+; " Memory listing"+CHR(13)+; REPLICATE("=",50)+CHR(13) ; ADDITIVE LIST MEMORY TO (lcErrData) NOCONSOLE APPEND MEMO listing FROM (lcErrData) ERASE (lcErrData) SELECT (liSelect) ENDPROC PROCEDURE doerrorlogui LPARAMETERS tcAlias * this code is really expecting to be overridden IF NOT THIS.lServer BROWSE NORMAL NOWAIT ENDIF ENDPROC PROCEDURE recordservererror LPARAMETERS tcMessage LOCAL lcMessage lcMessage = TRANSFORM(tcMessage) THIS.SetLog() INSERT INTO (THIS.cLogAlias) ("Errstamp") VALUES (DATETIME()) REPLACE Listing WITH lcMessage IN (THIS.cLogAlias) ENDPROC PROCEDURE isdisallowedserveraction LPARAMETERS tlWantRecord LOCAL llDisallowedServerAction IF THIS.lServer AND ; (THIS.iCurrentError = 2031 OR ; (THIS.iCurrentError = 1001 AND ; _VFP.Startmode = 5) ) llDisallowedServerAction = .T. IF tlWantRecord THIS.RecordServerError(; THIS.cCurrentMessage+CHR(13)+; THIS.cCurrentErrorParam+CHR(13)+; TRANS(THIS.iCurrentError)+CHR(13)+; THIS.cCurrentMethod+CHR(13)+; TRANS(THIS.iCurrentLine)) ENDIF ENDIF RETURN llDisallowedServerAction ENDPROC PROCEDURE Destroy LOCAL liSession liSession = SET("DATASESSION") SET DATASESSION TO 1 IF USED(THIS.cLogAlias) USE IN (THIS.cLogAlias) * this is actually only going to happen * in the "default" datasession * because any other USEs should have * been closed when their forms and formsets * died by this point. * note that the errorlog may be opened * many times in different sessions, and * this session information will be reflected in the log ENDIF SET DATASESSION TO liSession DODEFAULT() ENDPROC PROCEDURE Error LPARAMETERS nError, cMethod, nLine * special case, must override * any use of ON ERROR which * might call this object recursively IF "setlog" $ LOWER(cMethod) THIS.cLogDBF = "" ELSE ERROR ERROR_IN_ERROR_METHOD_LOC+":"+CHR(13)+ ; "#"+TRANSFORM(nError)+CHR(13)+ ; THIS.Name+" "+cMethod+", "+TRANSFORM(nLine)+CHR(13)+ ; THIS.cCurrentMessage ENDIF ENDPROC ccurrentmessage = ("") ccurrentmethod = ("") icurrenterror = 0 icurrentline = 0 ccurrentclass = ("") lserver = (INLIST(_VFP.StartMode,1,2,3,5)) clogalias = ("") clogdbf = ("") ccurrenterrorparam = ("") Name = "_error"